Attribute VB_Name = "callBack"
' 本次主要升级
'  1.工作簿合并
'  2.工作表合并
'  3.按列拆分
' 为精简代码，过往功能请查看之前的文章

Option Explicit

'多工作簿的表合并在当前文件中()
Sub workbooksMerge(control As IRibbonControl)

    Dim activeShtName As String
    activeShtName = activesheet.Name  ' 获取当前激活的工作表名，方面后续再次激活
    Dim actWb As Workbook
    Set actWb = ActiveWorkbook

    On Error GoTo endSubLine '防止用户点击取消出错
    Dim userSelectFilesPathArr()           ' 存储用户选择的工作簿文件
    userSelectFilesPathArr = Excel.Application.GetOpenFilename("Excel数据文件, *.xls*;*.xla*;*.xlt*", Title:="请选择要合并的文件", MultiSelect:=True)
    On Error GoTo 0 ' 恢复错误捕获
    Application.ScreenUpdating = False

    Dim i As Long, wb As Workbook
    For i = LBound(userSelectFilesPathArr) To UBound(userSelectFilesPathArr)
        Set wb = Workbooks.Open(userSelectFilesPathArr(i))
        Dim sht As Worksheet
        For Each sht In wb.Worksheets
            If sht.Visible = xlSheetVisible Then
                sht.Copy After:=actWb.Worksheets(actWb.Worksheets.Count)    ' 复制在最后的位置，没有返回值
                actWb.Sheets(actWb.Worksheets.Count).Name = Left(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".")) & "_" & sht.Name
            End If
        Next
        wb.Close
    Next

    Application.ScreenUpdating = True

endSubLine:
    actWb.Worksheets(activeShtName).Activate
End Sub


Sub worksheetsMerge(control As IRibbonControl)

    If MsgBox("请确定已选择要合并的sheet！", vbOKCancel) <> vbOK Then
        Exit Sub
    End If

    ' 1. 将选中工作表存入数组，防止新建/切换工作表时发生变化
    Dim selectedSheetsNameArr() As String
    ReDim selectedSheetsNameArr(1 To ActiveWindow.SelectedSheets.Count) '选中的工作表名称

    Dim sht As Variant  'Chart、WorkSheet
    Dim i As Long: i = 0
    For Each sht In ActiveWindow.SelectedSheets
        If sht.Type = xlWorksheet Then  ' 仅存放 Worksheet
            i = i + 1
            selectedSheetsNameArr(i) = sht.Name
        End If
    Next
    ReDim Preserve selectedSheetsNameArr(1 To i)


    ' 2. 让用户选择数据所在的最左上位置
    ' 2.1 重置选择工作表，兼容WPS
    Dim activeSht As Worksheet
    Set activeSht = Worksheets(selectedSheetsNameArr(1))
    activeSht.Select Replace:=True
    ' 2.2 用户选择单元格
    On Error Resume Next '防止点击取消发生错误
    Dim dataStartRange As Range
    Set dataStartRange = Excel.Application.InputBox(" 请选择非标题的数据区域的最左上单元格", Type:=8)
    If dataStartRange Is Nothing Then
        MsgBox ("您未选择单元格，程序已结束")
        Exit Sub
    End If
    On Error GoTo 0

    Excel.Application.ScreenUpdating = False

    ' 2.3 获取用户选择单元格的各种信息
    Dim dataStartRangeAddress As String, dataStartRangeRow As Long, dataStartRangeColumn As Long
    dataStartRangeAddress = dataStartRange.Address(0, 0)
    dataStartRangeRow = dataStartRange.Row
    dataStartRangeColumn = dataStartRange.Column

    ' 3. 创建用于合并的工作表
    Dim mergeSht As Worksheet
    Set mergeSht = Worksheets.Add(before:=Sheets(1), Count:=1) '需添加count，因为默认会添加你选择sheet的数量

    ' 4. 循环遍历，复制粘贴
    Dim mergeShtStartRangeRow As Long
    mergeShtStartRangeRow = dataStartRangeRow   '设置起始行号
    For i = LBound(selectedSheetsNameArr) To UBound(selectedSheetsNameArr)
        With Worksheets(selectedSheetsNameArr(i))

            ' 如果有数据
            If .Range(dataStartRangeAddress).CurrentRegion.Cells.Count > 1 Then
                ' 标题范围
                Dim theadRange As Range
                Set theadRange = Intersect(.Rows("1:" & dataStartRangeRow - 1), .Range(dataStartRangeAddress).CurrentRegion)
                If theadRange Is Nothing Then    ' 如果标题部分为空
                    Exit For    ' 不再继续判断+读取数据范围
                Else
                    If i = 1 Then   ' 只复制一次，其他的不复制
                        theadRange.Copy mergeSht.Range(theadRange.Cells(1).Address(0, 0))
                        mergeSht.Columns("A:A").Insert Shift:=xlToRight '插入一列用户填写工作表
                        With mergeSht.Range(theadRange.Cells(1).Address(0, 0)).Resize(theadRange.Rows.Count, 1)
                            .Merge
                            .Value = "工作表名称"
                        End With
                    End If
                End If

                ' 数据范围
                Dim tbodyRange As Range
                Set tbodyRange = Intersect(.Range(.Range(dataStartRangeAddress), .Cells(.Cells.Rows.Count, .Cells.Columns.Count)), .Range(dataStartRangeAddress).CurrentRegion)
                tbodyRange.Copy mergeSht.Cells(mergeShtStartRangeRow, dataStartRangeColumn + 1)
                mergeSht.Range(mergeSht.Cells(mergeShtStartRangeRow, dataStartRangeColumn), mergeSht.Cells(mergeShtStartRangeRow + tbodyRange.Rows.Count - 1, dataStartRangeColumn)).Value = .Name
                mergeShtStartRangeRow = mergeShtStartRangeRow + tbodyRange.Rows.Count
            End If
        End With
    Next

    Excel.Application.ScreenUpdating = True
    mergeSht.Select
    MsgBox "已完成工作表的合并！"

End Sub

'按列拆分表格()
Sub createWorksheetsByColumn(control As IRibbonControl)

    If MsgBox("请确定以下内容：" & Chr(10) _
    & "1. 该Sheet为清单式表格(首行为标题行，首列在A列且不为空)" & Chr(10) _
    & "2. 已选择拆分的依据列中的某单元格", vbOKCancel) = vbOK Then
        Const blackShtName As String = "空白字段表"

        Excel.Application.DisplayAlerts = False
        Excel.Application.ScreenUpdating = False
        Dim actsht As Worksheet
        Set actsht = activesheet '存储当前活动的sheet名称

        With actsht

            ' 1. 获取选中单元格信息
            Dim activeCellColnum As Long
            activeCellColnum = ActiveCell.Column
            Dim actshtCurrentRegionAddress As String
            actshtCurrentRegionAddress = actsht.Range("A1").CurrentRegion.Address

            ' 2. 禁用筛选，防止出错
            .Range("A1").CurrentRegion.AutoFilter

            ' 3. 获取不重复的列数据作为表名
            Dim arr
            arr = Intersect(actsht.Range("A1").CurrentRegion, actsht.Columns(activeCellColnum)).Value

            Dim dict As Object
            Set dict = CreateObject("scripting.dictionary")
            Dim i As Long
            For i = LBound(arr) To UBound(arr)
                If arr(i, 1) <> .Cells(1, activeCellColnum).Value Then
                    dict(arr(i, 1)) = ""
                End If
            Next

            ' 4. 遍历复制粘贴

            Dim k As Variant
            For Each k In dict.keys

                Dim tempShtName As String
                If k <> "" Then
                    tempShtName = k & ""
                Else
                    tempShtName = blackShtName
                End If

                Dim sht As Worksheet
                '按名称新建表格于最后
                ' 如果存在则让用户判断是否删除
                If Evaluate("ISREF('" & tempShtName & "'!A1)") Then
                    Excel.Application.ScreenUpdating = True
                    Worksheets(tempShtName).Select
                    Dim msg As Long
                    msg = MsgBox("已有相同名称的工作表「" & tempShtName & "」，是否删除后重试？" & Chr(13) & "是(Y)：删除  否(N)：新建工作表  取消：跳过", vbYesNoCancel)
                    If msg = vbYes Then
                        Worksheets(tempShtName).Delete
                        Set sht = Worksheets.Add(After:=Sheets(Sheets.Count))
                        sht.Name = tempShtName
                    ElseIf msg = vbNo Then
                        Set sht = Worksheets.Add(After:=Sheets(Sheets.Count))
                        sht.Name = tempShtName & "_副本"
                    Else
                        GoTo gotoNext
                    End If
                    Excel.Application.ScreenUpdating = False
                Else    ' 否则创建新工作表
                    Set sht = Worksheets.Add(After:=Sheets(Sheets.Count))
                    sht.Name = tempShtName
                End If

                '复制对应内容到指定表格
                actsht.Range(actshtCurrentRegionAddress).AutoFilter Field:=activeCellColnum, Criteria1:=k    '启动筛选
                ' k & ""避免条件为数字，干扰选择
                actsht.Range(actshtCurrentRegionAddress).Copy sht.[A1]
gotoNext:
            Next

            '取消筛选
            .Select
            .Range("A1").CurrentRegion.AutoFilter

        End With

        Excel.Application.ScreenUpdating = False
        Excel.Application.DisplayAlerts = True

        MsgBox "拆分完成"
    End If

End Sub
